Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Snippets/PNL Libraries/MyDriver.p

Text File | 1996-06-01 | 14KB | 485 lines

unit MyDriver;

{ Code thanks to Pete Resnick }

interface

    uses
        Devices;

    const
        dOpened = $0020;
        dRAMBased = $0040;

{$PUSH}
{$ALIGN MAC68K}

{ Structure of the driver resource }
    type
        DriverRecord = record
                drvrFlags: integer;
                drvrDelay: integer;
                drvrEMask: integer;
                drvrMenu: integer;
                drvrOpen: integer;
                drvrPrime: integer;
                drvrCtl: integer;
                drvrStatus: integer;
                drvrClose: integer;
                drvrName: Str63;
{ driver name and code follows }
            end;
        DriverPtr = ^DriverRecord;
        DriverHandle = ^DriverPtr;
        DCtlArray = array[0..1000] of DCtlHandle;
        DCtlArrayPtr = ^DCtlArray;

{$ALIGN RESET}
{$POP}

{ These two routines are the ones you want to call }
    function InstallRAMDriver (name: Str255; var refnum: integer; openit: boolean): OSErr;
    function RemoveRAMDriver (refnum: integer): OSErr;

    function DriverIsOpen (name: Str255): boolean;

{ These are used internally but might be useful in unusual circumstances }
    function GetDriverRefNum (name: Str255): integer;
    function SizeUTable (entries: integer): OSErr;
    function DriverAvail (var unitNum: integer): OSErr;
    function Get1XResource (var rsrcHndl: Handle; rsrcType: ResType; rsrcID: integer; rsrcInd: integer; rsrcName: StringPtr): OSErr;
    function Get1SysXRsrc (var rsrcHndl: Handle; rsrcType: ResType; rsrcID: integer; rsrcInd: integer; rsrcName: StringPtr): OSErr;
    function PtrInZone (theZone: THz; thePtr: univ Ptr): boolean;
    function HandleInZone (theZone: THz; theHandle: univ Handle): boolean;

{ Undefined, but documented routines }
    function DriverInstall (drvrHandle: Handle; refnum: integer): OSErr;
    inline
        $301F, $205F, $2050, $A03D, $3E80;
    function DriverRemove (refnum: integer): OSErr;
    inline
        $301F, $A03E, $3E80;

{ Interupt enable/disable }
    function DisableInterrupts: integer;
    inline
        $4007, $46FC, $2600;
    procedure ResetStatusRegister (oldSR: integer);
    inline
        $46DF;

{ Access low memory globals }
    function LMUTableBase: DCtlArrayPtr;
    inline
        $2EB8, $011C;

    procedure LMSetUTableBase (addr: univ DCtlArrayPtr);
    inline
        $21DF, $011C;

    function LMUnitEntryCount: integer;
    inline
        $3EB8, $1D2;

    procedure LMSetUnitEntryCount (n: integer);
    inline
        $31DF, $01D2;

implementation

    uses
        Resources,TextUtils;

{ *    The following code is to install and remove RAM drivers in the system}
{ *    heap. Written by Pete Resnick with the help of J. Geagan, Joe Holt,}
{ *    Tom Johnson, Michael A. Libes, Charles Martin, John Norstad, Phil}
{ *    Shapiro, Eric Braun, David Brown and Matthias Urlichs. Feel free to}
{ *    use this in your code, though I do ask that you give credit. Please}
{ *    report any bugs to Pete Resnick - [e-mail]. Please read}
{ *    the README file and check defines in drvrincludes.h before you use}
{ *    this code!!}
{ *}
{ *    Change Log}
{ *    ----------}
{ *    Date:        Change:                                                Who:}
{ *    -----        -------                                                ----}
{ *    6/2/92        Changed ThinkCleanup so that it compiles and works    pr}
{ *    6/22/92        Corrected declaration of DisableInterrupts            eb}
{ *    7/1/92        Corrected declaration of DrvrInstall and DrvrRemove    eb/pr}
{ *    10/15/92    Changed Get1SysRsrc to Get1SysXRsrc                    pr}
{ *    10/18/92    Got rid of thinkReOpen; just return 1 from close    pr}
{ *                Fixed up PtrInZone to make it a little quicker        pr}
{ *    11/6/92        Got rid of auto initialize for newCode and oldCode    pr}
{ *                Changed PBxxx calls to PBxxxSync                    pr}
{ *    11/8/92        A little cleanup; moved a few things                pr}
{ *    12/17/92    Added HNoPurge to Get1SysXRsrc                        db/pr}
{ *    1/24/93        Fixed double deletion of DATA Handle and dispose    db/pr}
{ *                of code Handle -- major changes to all ThinkXXX}
{ *                routines and THINKProc.c}
{ *    2/5/93        Made DriverAvail a little more efficent                pr}
{ *    2/6/93        Re-wrote all of the Think routines and THINKProc.c    pr}
{ *                so that the THINK proc is a pointer instead of a}
{ *                Handle (needed for locked drivers).}
{ *    2/23/93        Passed drvrInstFlags to RemoveRAMDriver    from        pr}
{ *                InstallRAMDriver error}
{ *    10/21/93    Check for nil handles in RemoveRAMDriver            pr}
{ *                Zero out close block in RemoveRAMDriver}
{ *                Prettified GetDriverRefNum}
{ *                Moved DisableInterrupts, ResetInterrupts,}
{ *                DrvrInstall, and DrvrRemove from driver.h to}
{ *                drvrincludes.h}
{ *                    }
{ *    19940212    Convert to Pascal                PNL}


{ *    InstallRAMDriver will install the named driver into the system heap}
{ *    return the driver reference number in refNum. }

    function InstallRAMDriver (name: Str255; var refnum: integer; openit: boolean): OSErr;
        var
            err, junk: OSErr;
            drvrHandle: Handle;
            rsrcType: ResType;
            rsrcID, unitNum: integer;
            hndlState: SignedByte;
            ctlEntryPtr: DCtlPtr;
            drvrPtr: DriverPtr;
            pb: ParamBlockRec;
    begin

        err := noErr;

        if GetDriverRefNum(name) <> 0 then
            err := badUnitErr;

        if err = noErr then
            err := DriverAvail(unitNum);

        if err = noErr then
            err := Get1SysXRsrc(drvrHandle, 'DRVR', 0, 0, @name);
{ Why not just rely on the resource being set to system and non-purgeable and just use Get1NamedResource??? }

        if err = noErr then begin
            GetResInfo(drvrHandle, rsrcID, rsrcType, name);
            err := ResError;

            if err = noErr then begin
                DetachResource(drvrHandle);
                err := ResError;
            end;

            if err <> noErr then
                ReleaseResource(drvrHandle);
        end;

        if err = noErr then begin

    { Install DRVR with the refNum.  }
            refnum := -(unitNum + 1);
            hndlState := HGetState(drvrHandle);
            HLock(drvrHandle);
            err := DriverInstall(drvrHandle, refnum);
            HSetState(drvrHandle, hndlState);

    { Cleanup on errors }
            if err <> noErr then
                DisposeHandle(drvrHandle);
        end;

        if err = noErr then begin
    { Move the important information to the driver entry }
            ctlEntryPtr := GetDCtlEntry(refnum)^;
            drvrPtr := DriverHandle(drvrHandle)^;
            ctlEntryPtr^.dCtlDriver := Ptr(drvrHandle);
            ctlEntryPtr^.dCtlFlags := BOR(drvrPtr^.drvrFlags, dRAMBased);
            ctlEntryPtr^.dCtlDelay := drvrPtr^.drvrDelay;
            ctlEntryPtr^.dCtlEMask := drvrPtr^.drvrEMask;
            ctlEntryPtr^.dCtlMenu := drvrPtr^.drvrMenu;

    { Open the driver }
            if openit then begin
                pb.ioCompletion := nil;
                pb.ioNamePtr := @name;
                pb.ioPermssn := fsCurPerm;
                err := PBOpenSync(@pb);
            end;

    { If an error occurred during the open, remove the DRVR }
            if err <> noErr then
                junk := RemoveRAMDriver(refnum);
        end;

        InstallRAMDriver := err;
    end;


{ *    RemoveRAMDriver removes the driver installed in the system heap by}
{ *    InstallRAMDriver.}

    function RemoveRAMDriver (refnum: integer): OSErr;
        var
            err: OSErr;
            drvrHandle: Handle;
            ctlEntryHndl: DCtlHandle;
            pb: ParamBlockRec;
    begin
        err := noErr;

    { Get the driver control entry }
        ctlEntryHndl := GetDCtlEntry(refNum);
        if ctlEntryHndl = nil then
            err := unitEmptyErr;

    { Check for nil Handle }
        if (err = noErr) & (ctlEntryHndl^ = nil) then
            err := nilHandleErr;

        if err = noErr then begin
    { Get the driver Handle }
            drvrHandle := Handle(ctlEntryHndl^^.dCtlDriver);

{ close the driver }
            if BAND(ctlEntryHndl^^.dCtlFlags, dOpened) <> 0 then begin
                pb.ioResult := 0;
                pb.ioNamePtr := nil;
                pb.ioVRefNum := 0;
                pb.ioRefNum := refNum;
                pb.ioPermssn := 0;
                err := PBCloseSync(@pb);
            end;

            if err = noErr then begin
    { Remove the driver }
                HLock(drvrHandle);
                err := DriverRemove(refNum);
            end;

{ Dispose of the driver code (nil-safe) }
            DisposeHandle(drvrHandle);
        end;

        RemoveRAMDriver := err;
    end;


{ *    GetDriverRefNum simply searches through each driver control entry}
{ *    for a driver with the same name as that specified in name.}
{ *    If found, the reference number is returned. If no driver is found}
{ *    by that name, 0 is returned. Reads the low-memory global UnitNtryCnt.}

    function GetDriverRefNum (name: Str255): integer;
        var
            unitnum: integer;
            curDCtlHndl: DCtlHandle;
            curDriverPtr: DriverPtr;
    begin
        GetDriverRefNum := 0;
        for unitnum := 0 to LMUnitEntryCount - 1 do begin
            curDCtlHndl := LMUTableBase^[unitnum];
            if curDCtlHndl <> nil then begin
                curDriverPtr := DriverPtr(curDCtlHndl^^.dCtlDriver); { If this is a RAM driver, it's a Handle. ROM is a pointer }
                if (curDriverPtr <> nil) & (BAND(curDCtlHndl^^.dCtlFlags, dRAMBased) <> 0) then begin
                    curDriverPtr := DriverPtr(Handle(curDriverPtr)^);
                end;
                if (curDriverPtr <> nil) & EqualString(name, curDriverPtr^.drvrName, false, true) then begin
                    GetDriverRefNum := -(unitNum + 1);
                    leave;
                end;
            end;
        end;
    end;


{ *    SizeUTable sets the size of the driver unit table.}
{ *    Interrupts must be disabled during this operation. Changes the}
{ *    low-memory globals UTableBase and UnitNtryCnt.}

    function SizeUTable (entries: integer): OSErr;
        var
            newUTableBase, oldUTableBase: Ptr;
            oldSR: integer;
            err: OSErr;
    begin
    { Make new Unit Table }
        newUTableBase := NewPtrSysClear(longint(entries) * SizeOf(DCtlHandle));
        err := MemError;

        if err = noErr then begin
    { Any Device Manager action now would be bad! }
            oldSR := DisableInterrupts;

    { Move the old Unit Table to the new Unit Table }
            BlockMove(Ptr(LMUTableBase), newUTableBase, longint(LMUnitEntryCount) * SizeOf(DCtlHandle));
            oldUTableBase := Ptr(LMUTableBase); { Dispose after re-enabling interupts }
            LMSetUTableBase(newUTableBase);
            LMSetUnitEntryCount(entries);

    { Renable interrupts }
            ResetStatusRegister(oldSR);

            DisposePtr(oldUTableBase);
        end;
        SizeUTable := err;
    end;


{ *    DriverAvail finds the first available slot in the unit table to}
{ *    install the new device driver. It will call SizeUTable if there is}
{ *    not enough room in the current unit table. It will return the first}
{ *    available slot between LOW_UNIT and UP_UNIT. Reads the low-memory}
{ *    global UTableBase and may change as well as read the low-memory global}
{ *    UnitNtryCnt.}

    const
        LOW_UNIT = 48;        { First Unit Table Entry to use        }
        NEW_UNIT = 64;    { Size of a "normal" Unit Table        }
        MAX_UNIT = 128;    { Maximum size of a Unit Table            }
        UP_UNIT = 4;        { Size to bounce up Unit Table            }

    function DriverAvail (var unitNum: integer): OSErr;
        var
            unitIndex: integer;
            UTableSize: integer;
            newsize: integer;
            err: OSErr;
    begin
        err := noErr;
        unitNum := 0;

        { Look for an empty slot in what's already there }
        for unitIndex := LOW_UNIT to LMUnitEntryCount - 1 do begin
            if LMUTableBase^[unitIndex] = nil then begin
                unitNum := unitIndex;
                leave;
            end;
        end;

        if unitnum = 0 then begin
            UTableSize := GetPtrSize(Ptr(LMUTableBase)) div SizeOf(DCtlHandle); { the real size of the table }

            if (LOW_UNIT < UTableSize) & (LMUnitEntryCount < UTableSize) then begin
                { We can fit the new entry in the current table }
                if LMUnitEntryCount < LOW_UNIT then begin { Expand to LOW_UNIT first }
                    LMSetUnitEntryCount(LOW_UNIT);
                end;
                unitNum := LMUnitEntryCount;
                LMSetUnitEntryCount(LMUnitEntryCount + 1);
                err := noErr;
            end
            else if UTableSize < MAX_UNIT then begin
                { we *can* increase the table size }
                newsize := UTableSize + UP_UNIT;
                if newsize < NEW_UNIT then begin
                    newsize := NEW_UNIT;
                end
                else if newsize > MAX_UNIT then begin
                    newsize := MAX_UNIT;
                end;
                unitNum := LMUnitEntryCount;
                err := SizeUTable(newsize);
                if err <> noErr then begin
                    unitNum := 0;
                end;
            end
            else begin
                err := unitTblFullErr;
            end;
        end;

        DriverAvail := err;
    end;


{ *    Get1XResource gets a Handle to a resource. The resource}
{ *    will be retrieved according to resource type and either resource name,}
{ *    or resource index, or resource ID, in that order, whichever is}
{ *    non-zero.}

    function Get1XResource (var rsrcHndl: Handle; rsrcType: ResType; rsrcID: integer; rsrcInd: integer; rsrcName: StringPtr): OSErr;
        var
            err: OSErr;
    begin
        if rsrcName <> nil then begin
            rsrcHndl := Get1NamedResource(rsrcType, rsrcName^);
        end
        else if rsrcInd <> 0 then begin
            rsrcHndl := Get1IndResource(rsrcType, rsrcInd);
        end
        else begin
            rsrcHndl := Get1Resource(rsrcType, rsrcID);
        end;
        err := ResError;
        if (err = noErr) & (rsrcHndl = nil) then
            err := resNotFound;
        Get1XResource := err;
    end;


{ *    Get1SysXRsrc gets a Handle to the requested resource making sure that}
{ *    both the resource itself and the master pointer are in the system heap}
{ *    and non-purgeable. }

    function Get1SysXRsrc (var rsrcHndl: Handle; rsrcType: ResType; rsrcID: integer; rsrcInd: integer; rsrcName: StringPtr): OSErr;
        var
            savedZone, tempSysZone: THz;
            err, ptrCode: OSErr;
    begin
    { Make sure everything loads in the system heap }
        savedZone := GetZone;
        tempSysZone := SystemZone;
        SetZone(tempSysZone);
        SetResLoad(true);

        err := Get1XResource(rsrcHndl, rsrcType, rsrcID, rsrcInd, rsrcName);
        if (err = noErr) & not HandleInZone(tempSysZone, rsrcHndl) then begin
            ReleaseResource(rsrcHndl);
            err := Get1XResource(rsrcHndl, rsrcType, rsrcID, rsrcInd, rsrcName);
        end;
        if (err = noErr) & not HandleInZone(tempSysZone, rsrcHndl) then begin
            ReleaseResource(rsrcHndl);
            err := memAZErr;
        end;
        if err = noErr then begin
            HNoPurge(rsrcHndl);
        end;

    { Restore the zone to what it was }
        SetZone(savedZone);
        Get1SysXRsrc := err;
    end;


{ *    PtrInZone just checks to see whether the specified pointer is within}
{ *    the specified zone.}

    function PtrInZone (theZone: THz; thePtr: univ Ptr): boolean;
        var
            stripMask, testPtr, dataStart, dataLim: longint;
    begin
        testPtr := longint(StripAddress(thePtr));
        dataStart := longint(StripAddress(@theZone^.heapData));
        dataLim := longint(StripAddress(theZone^.bkLim));
        PtrInZone := (dataStart <= testPtr) & (testPtr < dataLim);
    end;


{ *    HandleInZone just checks to see whether the specified pointer is within}
{ *    the specified zone.}

    function HandleInZone (theZone: THz; theHandle: univ Handle): boolean;
    begin
        HandleInZone := PtrInZone(theZone, theHandle) & PtrInZone(theZone, theHandle^);
    end;


{ *    DriverIsOpen is self evident }

    function DriverIsOpen (name: Str255): boolean;
        var
            refnum: integer;
    begin
        refnum := GetDriverRefNum('.ipp');
        DriverIsOpen := (refnum <> 0) & (BAND(GetDCtlEntry(refnum)^^.dCtlFlags, dOpened) <> 0);
    end;

end.